/*
 *	Plurals
 *
 *	Author:	S.C.Merrall
 *
 *	File:	mp_eubang.m
 *
 *	Contents:	mp_make_plural
 *			mp_make_context
 *			mp_plural
 *			mp_init_plural
 *                      mp_length
 *                      mp_match
 *                      mp_move
 *			mp_stat
 *			cm_start
 *			cm_put
 *
 *	Description:	   Functions for creating and manipulating plurals.
 *			One major function which acts as a generalised 
 *			interface between the front end and back end. Since
 *			operations have the same general code to convert
 *			from an MP_Plural object address to a set of heap
 *			locations.
 *
 *	Change History:
 *
 *	Date   Name Comment
 *    -------- ---- -------
 *    21:05:91 SCM  Created
 *    23:05:91 SCM  Added mp_error, error indicator to the front end
 *    28:06:91 SCM  Context seperated from plural, connected of FE only
 *    **:02:92 SCM  Function for CM-Lisp v1, cm_identify
 *    **:03:92 SCM  Functions for CM-lisp v2, cm_put, cm_start
 *    26:03:92 SCM  cm_identify removed
 *    06:04:92 SCM  initialise t, nil to be proper objects with special address
 *
 */

#include <mpl.h>
#include <stdio.h>
#include "proc_pair.h"

#include "mp_eubang.h"	/*  Includes constant.h too */

#include "mp_object.h"
#include "mp_debug_off.h"
#include "mp_mem_mgmt.h"
#include "mp_gc.h"
#include "mp_utils.h"

visible int private_nproc;      /*  So the host knows how much memory to allocate
			 *  for its scratch space */

visible int mp_error;	/*  Integer visible to the front end so we can use
			 *  it to indicate the error that has occurred.
			 */ 


/*----------------------------------------------------------------------------*
 * Function   : mp_make_context
 *
 * Parameters : int width:	Width of the context
 *		int height:	Height of the context
 *
 * Description: Creates a context handle. identifies a rectangular set of
 *		processors and allocates a new context stack on them.
 *		When a non rectangular set is requested the front end lisp
 *		will munge the context stack to deactivate extra elements.
 *
 * Result     : char *:	Address of context handle
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible char *mp_make_context( int width, int height )

#else

visible char *mp_make_context( width, height )

int width;
int height;

#endif

{
  object MPC_new;
  MP_PluralHeap MPPH_context_stack;
DBG_CALL("mp_make_context");
DBG_ARGS(fprintf(dbg,"width=%d, height=%d",width,height));
  set_gc_message();

  mp_error = MP_GREEN;


  PP_on_set() {

    if ((MPC_new = OF_create(OC_MP_Context)(width,height)) == NULL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to allocate new context"));
      mp_error = MP_ALLOC_CONTEXT_FAILED;
    }
    else OM_with_context(MPC_new) {

      MPP_2_MPPH(MPPH_context_stack, OA_offset(MPC_new));
    
      if (make_context_stack( MPPH_context_stack ) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to build new context stack"));
        mp_error = MP_MAKE_STACK_FAILED;
      }
    }
  }
  
  if (mp_error) return FAIL;

DBG_EXIT(fprintf(dbg,"%x",MPC_new));
  return (char *) MPC_new;
}


/*----------------------------------------------------------------------------*
 * Function   : mp_make_plural
 *
 * Parameters : object MPC_context:	MasPar Context object
 *
 * Description: Creates a new plural with context MPC_context. That is it finds
 *		an offset in the plural space such that on all the processors
 *		in MPC_context that offset is free. Marks the offsets as not
 *		being free and returns the offset
 *
 * Result     : int : 	Offset/FAIL
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int mp_make_plural( object MPC_context )

#else

visible int mp_make_plural( MPC_context )

object MPC_context;

#endif

{
  int result;
DBG_CALL("mp_make_plural");
DBG_ARGS(fprintf(dbg,"MPC_context=%x",MPC_context));
  set_gc_message();

  mp_error = MP_GREEN;

  PP_on_set() {

    if ((result = (int) alloc_plural(MPC_context)) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to allocate new plural"));
    mp_error = MP_ALLOC_PLURAL_FAILED;
    }
  }

  if (mp_error) return FAIL;

DBG_EXIT(fprintf(dbg,"%d",result));
  return result;
}

/*----------------------------------------------------------------------------*
 * Function   : mp_plural
 *
 * Parameters : int operation_id:	Unique identifier of the desired 
 *					operation.
 *		int no_of_args:		How many args have been supplied.
 *		int no_of_addresses:	How many of the args are mp_object
 *					addresses, (this will all be together
 *					at the beginning;
 *		char * arg1:		Each arg is a 32-bit word, representing
 *					either an object address, an
 *					integer or a front end address.
 *					This is determined by the operation
 *				...	
 *
 * Description:    Wrapper for all functions. Most operations require 
 *		converting an MasPar Plural object into a MasPar Plural
 *		Heap objec (that is a handle on the plurals heap space) and
 *		calling the appropriate lisp primitive.
 *
 * Result     : char *:		Again a 32-bit word which may be the address
 *				of a new object or an integer representing
 *				the result of the function. NULL usually
 *				indicates FAIL. 
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int    mp_plural(object MPC_context,
			 int operation_id,   
			 int no_of_args,     
			 int no_of_offsets,
			 int arg1,
			 int arg2,
			 int arg3 )

#else

visible int   mp_plural( MPC_context, operation_id, no_of_args, no_of_offsets,
			 arg1, arg2, arg3 )

object MPC_context;
int operation_id;
int no_of_args;
int no_of_offsets; 
int arg1;
int arg2;
int arg3;

#endif

{
  natural pe_x, pe_y;
  int result_status = SUCCESS;
  int return_value  = NULL;
  plural natural result_offsets = NIL;
  plural natural context;
  MP_PluralHeap MPPH_arg1;
  MP_PluralHeap MPPH_arg2;
  MP_PluralHeap MPPH_arg3;
  MP_PluralHeap MPPH_result = &result_offsets;
  MP_PluralHeap MPPH_context_stack;
  MP_PluralHeap MPPH_context = &context;
  char local_gc_message[60];
DBG_CALL("mp_plural");
DBG_ARGS(fprintf(dbg,"MPC_context=%x, operation_id=%d, no_of_args=%d, no_of_offsets=%d", MPC_context,operation_id, no_of_args, no_of_offsets));
  GC_Protect(result_offsets);
  sprintf(local_gc_message,"mp_plural,op_id=%d",operation_id);
  gc_message=local_gc_message;
  
  /* Convert addresses to MasPar Plural Heap objects */

  if (no_of_offsets >= 1) MPP_2_MPPH(MPPH_arg1,arg1);
  if (no_of_offsets >= 2) MPP_2_MPPH(MPPH_arg2,arg2);
  if (no_of_offsets >= 3) MPP_2_MPPH(MPPH_arg3,arg3);

  scratch[0] = NULL;
  if (operation_id == MP_X_STAT) scratch[0] = 0;

  PP_on_set() {
	
    if (operation_id == MP_X_STAT) scratch[0] = 1;

  OM_with_context(MPC_context) {

    if (operation_id == MP_X_STAT) scratch[0] = 2;

    /* Extract the current context */
    
    MPP_2_MPPH(MPPH_context_stack, OA_offset(MPC_context));
    if (car(MPPH_context_stack, MPPH_context) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to take car of context stack, op_id=%d",operation_id));
DBG_EROR(MP_CAR_OF_CONTEXT_FAIL);
    }

    if (operation_id == MP_IF) {

      /* Result_status is either FAIL, MP_NONE_ACTIVE, MP_SOME_ACTIVE */

DEBUG(DBG_PARG("ps[2589]","%d ",plural_memory[2589]));	
      if ((result_status = mp_if(MPPH_arg1, MPPH_context_stack)) == FAIL) {

	mp_error = MP_IF_FAILED;
      }
      else return_value =  result_status;
DEBUG(DBG_PARG("ps[2589]","%d ",plural_memory[2589]));	
    }
    else if (operation_id == MP_ELIF) {

      if ((result_status = mp_elif( MPPH_context_stack)) == FAIL) 
	mp_error = MP_ELIF_FAILED;
      else return_value - result_status;
    }
    else if (operation_id == MP_FI) {
      
      if ((result_status = mp_fi(MPPH_context_stack)) == FAIL) {

	mp_error = MP_FI_FAILED;
      }
    }
    else if (operation_id == MP_ELSE) {

      if ((result_status = mp_else(MPPH_context_stack)) == FAIL) {

	mp_error = MP_ELSE_FAILED;
      }
      else return_value = result_status;
    }
    else if (operation_id == MP_CONTEXT) {

      return_value = OA_offset(MPC_context);
      result_status = SUCCESS;
    }
    /* Operate conditionally on current context */

    else if (OA_offsets(MPPH_context) != NIL) {

      switch (operation_id) {

      case MP_PRINT :

	print( MPPH_arg1, (plural int) 0 );
	result_status = SUCCESS;
	return_value =  arg1;
	break;

      case MP_X_STAT :

	if( OA_offsets(MPPH_arg1) != NIL) scratch[0]=3;
	result_status = SUCCESS;
	return_value = arg1;
 	break;

      case MP_TEST :

	if ((result_status = test(MPPH_arg1,
				  (plural int)arg2,MPPH_result))==FAIL) {

	  mp_error = MP_TEST_FAILED;
	}
	break;

      case MP_EQ :

	if ((result_status = eq(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {

	  mp_error = MP_EQ_FAILED;
	}
	break;

      case MP_AND :

	if ((result_status = and(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {

	  mp_error = MP_AND_FAILED;
	}
	break;

      case MP_OR :

	if ((result_status = or(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {

	  mp_error = MP_OR_FAILED;
	}
	break;

      case MP_NOT :
	
	if ((result_status = not(MPPH_arg1,MPPH_result)) == FAIL)
	  mp_error = MP_NOT_FAILED;
	break;

      case MP_MP_CONS :
	
	if ((result_status = cons(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {

	  mp_error = MP_CONS_FAILED;
	}
	break;

      case MP_CAR :

	if ((result_status = car(MPPH_arg1,MPPH_result)) == FAIL) {

	  mp_error = MP_CAR_FAILED;
	}
	break;

      case MP_CDR :

	if ((result_status = cdr(MPPH_arg1,MPPH_result)) == FAIL) {

	  mp_error = MP_CDR_FAILED;
	}
	break;

      case MP_RPLAC_A :

	if ((result_status = rplac_a(MPPH_arg1,MPPH_arg2)) == FAIL) {

	  mp_error = MP_RPLAC_A_FAILED;
	}
	break;

      case MP_RPLAC_D :

	if ((result_status = rplac_d(MPPH_arg1,MPPH_arg2)) == FAIL) {

	  mp_error = MP_RPLAC_A_FAILED;
	}
	break;

      case MP_INT_BIN_OP :

	if ((result_status = int_bin_op(MPPH_arg1,MPPH_arg2,(plural int) arg3,
				      MPPH_result)) == FAIL) {
	    
	  mp_error = MP_INT_BIN_OP_FAILED;
	}
	break;

      case MP_BIN_OP :

DEBUG(fprintf(dbg,"arg1:%d: ",arg1);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg1)));
DEBUG(fprintf(dbg,"arg2:%d: ",arg2);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg2)));

	if ((result_status = bin_op(MPPH_arg1,MPPH_arg2,(plural int) arg3,
				    MPPH_result)) == FAIL) {
	    
	  mp_error = MP_BIN_OP_FAILED;
	}
	break;

      case MP_REL_OP :

	if ((result_status = rel_op(MPPH_arg1,MPPH_arg2,(plural int) arg3,
				    MPPH_result)) == FAIL) {
	    
	  mp_error = MP_REL_OP_FAILED;
	}
	break;

      case MP_UN_OP :

	if ((result_status = un_op(MPPH_arg1, (plural int) arg2, 
				   MPPH_result)) == FAIL) {

	  mp_error = MP_UN_OP_FAILED;
	}
	break;

      case MP_SCAN_OP :

	if ((result_status = scan_op(MPPH_arg1, (int) arg2, 
				   MPPH_result)) == FAIL) {

	  mp_error = MP_UN_OP_FAILED;
	}
	break;

      case MP_RANDOM :

	if ((result_status = rnd(MPPH_result)) == FAIL) 
	  mp_error = MP_RND_FAILED;
	break;

      case MP_MAKE_VECTOR :

	if ((result_status = make_vector(MPPH_arg1, MPPH_result)) == FAIL) {

	  mp_error = MP_MAKE_VECTOR_FAILED;
	}
	break;

      case MP_VECTOR_LENGTH :

	if ((result_status = vector_length(MPPH_arg1, MPPH_result)) == FAIL) {

	  mp_error = MP_VECTOR_LENGTH_FAILED;
	}
	break;

      case MP_VECTOR_REF :

	if ((result_status = vector_ref(MPPH_arg1, MPPH_arg2, 
					MPPH_result)) == FAIL) {

	  mp_error = MP_VECTOR_REF_FAILED;
	}
	break;

      case MP_ASSIGN :

DEBUG(DBG_PARG("MP_ASSIGN:cdr of stack","%d ",*(((plural natural *plural) OA_data(MPPH_context_stack)) + 1)));

DEBUG(fprintf(dbg,"arg1:%d: ",arg1);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg1)));
DEBUG(fprintf(dbg,"arg2:%d: ",arg2);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg2)));

	OA_offsets(MPPH_arg1) = OA_offsets(MPPH_arg2);
	result_status = SUCCESS;
	return_value = arg1;

DEBUG(fprintf(dbg,"arg1:%d: ",arg1);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg1)));

DEBUG(DBG_PARG("MP_ASSIGN:cdr of stack","%d ",*(((plural natural *plural) OA_data(MPPH_context_stack)) + 1)));

	break;

      case MP_VECTOR_SET :

	if ((result_status = vector_merge(MPPH_arg1, MPPH_arg2,
					MPPH_arg3)) == FAIL) {

	  mp_error = MP_VECTOR_SET_FAILED;
	}
	return_value = arg1;
	break;
	
      case MP_VECTOR_MERGE :

	if ((result_status = vector_merge(MPPH_arg1, MPPH_arg2, 
					  MPPH_result)) == FAIL) {

	  mp_error = MP_VECTOR_MERGE_FAILED;
	}
	break;

	
      case MP_REF :	

	/* arg1 is the address of an MP_Plural handle             */
	/* arg2 is the element to be set. 			  */
	/* The result is the processor id the element was one     */

	mp_error = MP_GREEN;

	if ((arg2 < 0) || ((int)arg2 >= (OA_width(MPC_context) *
					 OA_height(MPC_context)))) {

	  result_status = FAIL;
	  mp_error = MP_INDEX_OUTSIDE_PLURAL;
	}
	else {

	  return_value = OM_first(MPC_context)+(arg2 % OA_width(MPC_context)) +
	    (PP_nxproc * (arg2 / OA_width(MPC_context)));

	  if (PP_iproc == ((int) return_value)) {
	    
	    scratch[0] = 1;
	    encode(MPPH_arg1);
	  }
	  GC_UnProtect(1);
	  return ((return_value*2)+PP_left_right_proc);
	}
	break;

      case MP_SET :

	/* arg1 is the address an MP_Plural handle                */
	/* arg2 is the element of the plural to be set            */

	if ((arg2 < 0) || ((int)arg2 >= (OA_width(MPC_context) *
					 OA_height(MPC_context)))) {

	  result_status = FAIL;
	  mp_error = MP_INDEX_OUTSIDE_PLURAL;
	}
	else {

	  return_value = OM_first(MPC_context)+(arg2 % OA_width(MPC_context)) +
	    (PP_nxproc * (arg2 / OA_width(MPC_context)));
	  if (PP_iproc == (int)return_value) {

	    if ((result_status = fe_decode( MPPH_arg1, arg3 )) == FAIL) {
	    
	      mp_error = MP_BUILD_STRUCTURE_FAIL;
	    }
	    return_value  = arg1;
	  }
	}
	break;

      case MP_BANG :

	/* arg1 is the address of an front end description buffer */
      
	if ((result_status = fe_decode( MPPH_result, arg1 )) == FAIL) {
	  
	  mp_error = MP_BUILD_STRUCTURE_FAIL;
	}
	break;

	default :

	  result_status = FAIL;
      }
    }
  }   /* matches: OM_with_context() */
  }   /* matches: PP_on_set()       */

  if (result_status != FAIL) {

    if (return_value == NULL) {

      /* Operation was a success but we don;t know what to return      */
      /* Assume a result has been put into MPPH_result, need to create */
      /* a new plural to wrap around it                                */

      PP_on_set() return_value = alloc_plural(MPC_context);

      if (return_value == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to create plural for result, op id = %d",operation_id));
DBG_EROR(MP_ALLOC_PLURAL_FAILED);
      }
      
      PP_on_set() {
	OM_with_context(MPC_context) MPPH_2_MPP(return_value,MPPH_result);
      }
    }
  }
  else {

    GC_UnProtect(1);
DBG_FAIL(fprintf(dbg,"FAIL: Some error occurred, see mp_error, op id=%d",operation_id));
    return FAIL;
  }

  GC_UnProtect(1);
DBG_EXIT(fprintf(dbg,"SUCCESS"));
  return return_value;
}

/*----------------------------------------------------------------------------*
 * Function   : mp_init_plural
 *
 * Parameters : void
 *
 * Description:    Preforms any initialisation required, most importantly
 *		tells the front end where the PE scratch space is for the
 *		the purposes of communication via blockOut.
 *
 * Result     : char *:	Address of PE scratch space
 *			NULL if some failure occurs
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible char *mp_init_plural( void )

#else

visible char *mp_init_plural( )

#endif

{
  MP_PluralHeap MPPH_true;
  plural natural tmp;
  MP_PluralHeap MPPH_tmp = &tmp;

DBG_CALL("mp_init_plural");

  init_debug();

DBG_ARGS(fprintf(dbg,"void"));

  plural_memory = (plural natural *plural) heap_memory;

  init_proc_pair();

  /*  allocate, nil an t on each PE. These are special symbols with
   *  special addresses and identifiers 
   */

  if (mp_alloc((plural int) MP_SYMBOL, (plural int) 1, MPPH_tmp) == FAIL) {
DBG_FAIL(fprintf(dbg,"Unable to allocate nil!!!!"));
    return FAIL;
  }

  *(plural int *plural) OA_data(MPPH_tmp) = MP_NIL_ID;

  if (mp_alloc((plural int) MP_SYMBOL, (plural int) 1, MPPH_tmp) == FAIL) {
DBG_FAIL(fprintf(dbg,"Unable to allocate t!!!!)"));
  }

  *(plural int *plural) OA_data(MPPH_tmp) = MP_T_ID;

  private_nproc = nproc;
  if (nproc != MASPAR_CONFIG) {

DBG_EROR(MP_WRONG_MASPAR_CONFIG);
  }

DBG_EXIT(fprintf(dbg,"%x",(char *)scratch));
  return scratch;
}


/*  
 *  Communications
 *  ==============
 *
 *  These functions allow the user to define maps between sets of conformant
 *  plurals and move data along, in the fashion of paralation lisp
 *
 */

/*----------------------------------------------------------------------------*
 * Function   : mp_match
 *
 * Parameters : object MPC_dest:	Destination Context
 *		int    dest:		Destination Plural
 *		object MPC_from:	Source Context
 *		int    dest:		Source Plural
 *
 * Description: Creates a map between two contexts (not necesdsarily different)
 *		Using equality between the two plurals to define which
 *		elements of the source context are used to create each
 *		element of the destination context.
 *		The map has the form of a list of processor ids for each
 *		element of the destination context
 *
 * Result     : int:	Resulting map plural
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int mp_match( object MPC_dest, int dest,
		      object MPC_from, int from )
#else

visible int mp_match( MPC_dest, dest, MPC_from, from )

object MPC_dest;
int    dest;
object MPC_from;
int    from;

#endif

{
  int first,i;
  int map;
  int aok = TRUE;
  plural int to_values;
  plural int to_types;
  plural int from_values = -1;
  int from_value;
  plural int from_types;
  int from_type;
  plural natural result = NIL;
  MP_PluralHeap MPPH_result = &result;
  plural natural number = NIL;
  MP_PluralHeap MPPH_number = &number;
  MP_PluralHeap MPPH_from;
  MP_PluralHeap MPPH_dest;
  plural natural context;
  MP_PluralHeap MPPH_context = &context;
  MP_PluralHeap MPPH_context_stack;

DBG_CALL("mp_match");
DBG_ARGS(fprintf(dbg,"MPC_dest=%x,dest=%d,MPC_from=%x,from=%d", MPC_dest, 
		 dest, MPC_from, from ));
  set_gc_message();
  GC_Protect(result);
  GC_Protect(number);
  
  /* Convert to plural heap handles */

  MPP_2_MPPH(MPPH_dest,dest);
  MPP_2_MPPH(MPPH_from,from);

  PP_on_set() {

  /* Check these are both plurals of integers and or symbols */

  OM_with_context(MPC_from) {

    if (globalor((OA_info(MPPH_from) != INTEGER) && (OA_info(MPPH_from) != MP_SYMBOL))) {

      aok      = FALSE;
      mp_error = MP_MAP_SOURCE_NOT_INTS;
DBG_FAIL(fprintf(dbg,"FAIL: Source plural is not all integers"));
    }

    from_values = *(plural int *plural) OA_data(MPPH_from);
    from_types  = OA_info(MPPH_from);
  }

  if (aok) {

    OM_with_context(MPC_dest) {

      if (globalor((OA_info(MPPH_dest) != INTEGER) && (OA_info(MPPH_dest) != MP_SYMBOL))) {

	aok      = FALSE;
	mp_error = MP_MAP_DEST_NOT_INTS;
DBG_FAIL(fprintf(dbg,"FAIL: Destination plural is not all integers"));
      }

      MPP_2_MPPH(MPPH_context_stack, OA_offset(MPC_dest));
      if (car(MPPH_context_stack, MPPH_context) == FAIL) {
DBG_FAIL(fprintf(dbg,"FAIL: Unable to take car of context stack"));
	mp_error = MP_CAR_OF_CONTEXT_FAIL;
	return FAIL;
      }

      if (context != NIL) {

	to_values = *(plural int *plural) OA_data(MPPH_dest);
	to_types  = OA_info(MPPH_dest);
      
	first = OM_first(MPC_from);
	i = 0;
	while (((first + i) <= OM_last(MPC_from)) && aok) {
      
	  from_value = PP_proc(first + i).from_values;
	  from_type  = PP_proc(first + i).from_types;

	  if ((to_values == from_value) && (to_types == from_type)) {

DEBUG(DBG_PARG("iproc","%d ",iproc));
DEBUG(fprintf(dbg,"from_value=%d",from_value));

	    if ((aok == mp_alloc((plural int) INTEGER,
				 (plural int) 1, MPPH_number)) != FAIL) {

	      *(plural int *plural) OA_data(MPPH_number) = i+first;
	      aok = cons(MPPH_number, MPPH_result, MPPH_result);
	    }
	  }
	  i = i + 1;
	  if (i == OA_width(MPC_from)) {
	    i = 0;
	    first = first + PP_nxproc;
	  }
	}
      }
    }
  }
	
  if (aok) {

    if ((map = alloc_plural(MPC_dest, 0)) == FAIL) {

      aok = FALSE;
      mp_error = MP_ALLOC_PLURAL_FAILED;
DBG_FAIL(fprintf(dbg,"FAIL: Unable to create plural for map"));
    }

    else OM_with_context(MPC_dest) MPPH_2_MPP(map,MPPH_result);
  }
  }                                                  /* matches: PP_on_set() */

  GC_UnProtect(2);
  if (!aok) return FAIL;

DBG_EXIT(fprintf(dbg,"%d",map));
  return map;
}


/*----------------------------------------------------------------------------*
 * Function   : mp_move
 *
 * Parameters : object MPC_data:	Context of data
 *		int    data: 		Plural containing data to be moved
 *		object MPC_map:		Context of map
 *		int    map:		The map
 *		int    initial_value:	List of things already moved
 *					to this PE
 *
 * Description: Moves data down a map, this gives a new plural , conformant to
 *		the destination plural where each element contains a list of
 *		the objects from the source destination which were mapped
 *		to that location
 *		The addition of initial_value, is to make life easier
 *		in the virtual array case where several moves have
 *		to be done in order to get all the onjects to a given
 *		location. This means we can easily accumulate the
 *		the results in a single list rather than creating 
 *		several that then have to be merged.
 *
 * Result     : int:	FAIL/SUCCESS
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int mp_move( object MPC_data, int data, object MPC_map, 
		     int map, int initial_value )

#else

visible int mp_move( MPC_data, data, MPC_map, map, initial_value )

object MPC_data;
int data;
object MPC_map;
int map;
int initial_value;

#endif

{
  int aok = TRUE;
  MP_PluralHeap MPPH_data;
  plural natural tmp;
  MP_PluralHeap MPPH_tmp = &tmp;
  plural natural natural_map = NIL;
  MP_PluralHeap MPPH_map = &natural_map;
  MP_PluralHeap MPPH_result;
  plural natural natural_car = NIL;
  MP_PluralHeap MPPH_car = &natural_car;
  plural int procids = iproc;
  plural int index;
  plural char buf;
  int i;

DBG_CALL("mp_move");
DBG_ARGS(fprintf(dbg,"MPC_data=%x,data=%d,MPC_map=%x,map=%d,initial=%d",
		      MPC_data,data,MPC_map,map,initial_value));
  set_gc_message();
  GC_Protect(tmp);
  GC_Protect(natural_map);
  GC_Protect(natural_car);

  MPP_2_MPPH(MPPH_data,data);
  MPP_2_MPPH(MPPH_result,initial_value);
  PP_on_set() {

  OM_with_context(MPC_map) OA_offsets(MPPH_map) = plural_memory[map];

  while ((globalor(OA_offsets(MPPH_map) != NIL)) && (aok)) {

    scratch[0] = 1;
    OM_with_context(MPC_data) encode(MPPH_data);

    if (OA_offsets(MPPH_map) != NIL) {

DEBUG(DBG_PARG("*MPPH_map","%d ",OA_offsets(MPPH_map)));
DEBUG(DBG_PARG("*MPPH_result","%d ",OA_offsets(MPPH_result)));

      if ((aok = car(MPPH_map, MPPH_car)) == FAIL) {

	mp_error = MP_CAR_OF_MAP_FAILED;
DBG_FAIL(fprintf(dbg,"Unable to take car of map"));
      }
      else if ((aok = cdr(MPPH_map,MPPH_map)) == FAIL) {

	mp_error = MP_CDR_OF_MAP_FAILED;
DBG_FAIL(fprintf(dbg,"Unable to take cdr of map"));
      }
      else {

	procids = *(plural int *plural) OA_data(MPPH_car);
      
	for (i=0; i<SCRATCH_MEMORY_SIZE; i++) {

	  buf = PP_router(procids).scratch[i];
	  scratch[i] = buf;
	}

	index = 1;
	if ((aok = decode(MPPH_tmp, &index)) == FAIL) {

	  mp_error = MP_DECODE_IN_MOVE_FAILED;
DBG_FAIL(fprintf(dbg,"FAIL: decode stage of move failed"));
        }

	if ((aok = cons(MPPH_tmp, MPPH_result, MPPH_result)) == FAIL) {

	  mp_error = MP_CONS_COLLISIONS_FAILED;
DBG_FAIL(fprintf(dbg,"FAIL: Unable to cons up collisions"));
	}
      }
    }
  }
  if (!aok) {
DBG_FAIL(fprintf(dbg,"FAIL: mp_error=%d",mp_error));
}
  else {
DBG_EXIT(DBG_PARG("SUCCESS: *MPPH_result","%d ",OA_offsets(MPPH_result)));
}
  }

  GC_UnProtect(3);
  if (!aok) return FAIL;
  return SUCCESS;
}
       

/*  CM Hacks
 *  == =====
 *
 *  Whilst trying to write a quick version if CM Lisp for the MasPar I 
 *  discovered that although it could be done a few extra functions 
 *  paricularly in the communication section woule be useful. The
 *  first useful thing was something to help calculate intersections of
 *  the index xec. I am (as usual) working with integers only!
 *
 *  A second version oif CM-Lisp followd the implementation used by Steele
 *  in particular the rendezvous mechanism is used. This eliminates the
 *  need for cm_identify, two new functions are used instead. The first
 *  cm_put is probably worth hacking into eubang at some stage. The second,
 *  cm_start, is a useful optimisation when working out where to "put" things
 */

/*----------------------------------------------------------------------------*
 * Function   : cm_put
 *
 * Parameters : object MPC_data:	The context of the data to be putted
 *		int    data:		The offset  of the data to be putted
 *		int    dest:		The procids to put the dat too
 *		object MPC_dest:	The context of the resulting plural
 *		
 * Description: This is a function created for the CM Lisp interpreter, it 
 *		performs an operation which is analagous to an inverse of move
 *		But no collisions can occurr
 *
 * Result     : visible int: The offset of the resulting plural
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int cm_put( object MPC_data, int data, int dest, object MPC_dest )

#else

visible int cm_put( MPC_data, data, dest, MPC_dest )

object MPC_data;
int data;
int dest;
object MPC_dest;

#endif

{
  int i;
  plural int buf;
  plural char c_buf;
  plural int index;
  plural int *plural scratch_in_ints = (plural int *plural) scratch;
  int aok = TRUE;
  plural int dest_proc_ids = PP_iproc;
  plural int from_proc_ids = -1;
  plural int dest_proc_p   = FALSE;
  MP_PluralHeap MPPH_dest;
  MP_PluralHeap MPPH_data;
  plural natural nil = NIL;
  MP_PluralHeap MPPH_nil = &nil;
  int result_offset;
  plural natural result = NIL;
  MP_PluralHeap MPPH_result = &result;

DBG_CALL("cm_put");
DBG_ARGS(fprintf(stderr,"MPC_data=%x,data=%d,MPC_dest=%x,dest=%d",
		         MPC_data,data,MPC_dest,dest));
  set_gc_message();
  GC_Protect(nil);
  GC_Protect(result);

  MPP_2_MPPH(MPPH_data,data);
  MPP_2_MPPH(MPPH_dest,dest);

  PP_on_set() {

    OM_with_context(MPC_data) {

      dest_proc_ids = *(plural int *plural) OA_data(MPPH_dest);
      PP_router(dest_proc_ids).from_proc_ids = PP_iproc;
    }

    if ((from_proc_ids > -1) && (from_proc_ids < PP_nproc)) dest_proc_p = TRUE;
    else from_proc_ids = PP_iproc;
    scratch[0] = 1;
    OM_with_context(MPC_data) encode(MPPH_data);

    for (i=0; i<SCRATCH_MEMORY_SIZE/sizeof(int); i++) {

      buf = PP_router(from_proc_ids).scratch_in_ints[i];
      scratch_in_ints[i] = buf;
    }
 
    index = 1;

    if (dest_proc_p) {

      if ((aok = decode(MPPH_result, &index)) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: error whilst decoding - no space?"));
      }
      else if ((aok = cons(MPPH_result, MPPH_nil, MPPH_result)) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: unable to cons up putted objects"));   
      }
    }

    if (aok && ((aok = result_offset = alloc_plural(MPC_dest, 0)) != FAIL)) {

      OM_with_context(MPC_dest) plural_memory[result_offset] = result;
    }
    else {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to create plural for putted objects"));
    }
  }
  GC_UnProtect(2);
  if (!aok) return FAIL;

  return result_offset;
}
    
/*----------------------------------------------------------------------------*
 * Function   : cm_start
 *
 * Parameters : object MPC_context:	An MasPar Context object
 *
 * Description: We are interested in where the context starts, this will allow
 *		to move data from the rendezvous into it without having to do
 *		an expensive match operation
 *
 * Result     : int: The processor id
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int cm_start( object MPC_context )

#else

visible int cm_start( MPC_context )

object MPC_context;

#endif

{
  return OM_first(MPC_context);
}
